home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / printf.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  17.0 KB  |  581 lines
  1. ;;;; "printf.scm" Implementation of standard C functions for Scheme
  2. ;;; Copyright (C) 1991-1993, 1996 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'string-case)
  21.  
  22. ;; Parse the output of NUMBER->STRING.
  23. ;; Returns a list: (sign-character digit-string exponent-integer)
  24. ;; SIGN-CHAR will be either #\+ or #\-, DIGIT-STRING will always begin
  25. ;; with a "0", after which a decimal point should be understood.
  26. ;; If STR denotes a non-real number, 3 additional elements for the
  27. ;; complex part are appended.
  28. (define (stdio:parse-float str)
  29.   (let ((n (string-length str))
  30.     (iend 0))
  31.     (letrec ((prefix
  32.           (lambda (i rest)
  33.         (if (and (< i (- n 1))
  34.              (char=? #\# (string-ref str i)))
  35.             (case (string-ref str (+ i 1))
  36.               ((#\d #\i #\e) (prefix (+ i 2) rest))
  37.               ((#\.) (rest i))
  38.               (else (parse-error)))
  39.             (rest i))))
  40.          (sign
  41.           (lambda (i rest)
  42.         (if (< i n)
  43.             (let ((c (string-ref str i)))
  44.               (case c
  45.             ((#\- #\+) (cons c (rest (+ i 1))))
  46.             (else (cons #\+ (rest i))))))))
  47.          (digits
  48.           (lambda (i rest)
  49.         (do ((j i (+ j 1)))
  50.             ((or (>= j n)
  51.              (not (or (char-numeric? (string-ref str j))
  52.                   (char=? #\# (string-ref str j)))))
  53.              (cons
  54.               (if (= i j) "0" (substring str i j))
  55.               (rest j))))))
  56.          (point
  57.           (lambda (i rest)
  58.         (if (and (< i n)
  59.              (char=? #\. (string-ref str i)))
  60.             (rest (+ i 1))
  61.             (rest i))))
  62.          (exp
  63.           (lambda (i)
  64.         (if (< i n)
  65.             (case (string-ref str i)
  66.               ((#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L)
  67.                (let ((s (sign (+ i 1) (lambda (i) (digits i end!)))))
  68.              (list
  69.               (if (char=? #\- (car s))
  70.                   (- (string->number (cadr s)))
  71.                   (string->number (cadr s))))))
  72.               (else (end! i)
  73.                 '(0)))
  74.             (begin (end! i)
  75.                '(0)))))
  76.          (end!
  77.           (lambda (i)
  78.         (set! iend i)
  79.         '()))
  80.          (real
  81.           (lambda (i)
  82.         (let ((parsed
  83.                (prefix
  84.             i
  85.             (lambda (i)
  86.               (sign
  87.                i
  88.                (lambda (i)
  89.                  (digits
  90.                   i
  91.                   (lambda (i)
  92.                 (point
  93.                  i
  94.                  (lambda (i)
  95.                    (digits i exp)))))))))))
  96.           (and (list? parsed)
  97.                (apply
  98.             (lambda (sgn idigs fdigs exp)
  99.               (let* ((digs (string-append "0" idigs fdigs))
  100.                  (n (string-length digs)))
  101.                 (let loop ((i 1)
  102.                        (exp (+ exp (string-length idigs))))
  103.                   (if (and (< i n)
  104.                        (char=? #\0 (string-ref digs i)))
  105.                   (loop (+ i 1) (- exp 1))
  106.                   (list sgn (substring digs (- i 1) n) exp)))))
  107.             parsed)))))
  108.          (parse-error
  109.           (lambda () #f)))
  110.       (let ((realpart (real 0)))
  111.     (cond ((= iend n) realpart)
  112.           ((memv (string-ref str iend) '(#\+ #\-))
  113.            (let ((complexpart (real iend)))
  114.          (and (= iend (- n 1))
  115.               (char-ci=? #\i (string-ref str iend))
  116.               (append realpart complexpart))))
  117.           ((eqv? (string-ref str iend) #\@)
  118.            ;; Polar form:  No point in parsing the angle ourselves,
  119.            ;; since some transcendental approximation is unavoidable.
  120.            (let ((num (string->number str)))
  121.          (and num
  122.               (let ((realpart
  123.                  (stdio:parse-float
  124.                   (number->string (real-part num))))
  125.                 (imagpart
  126.                  (if (real? num)
  127.                  '()
  128.                  (stdio:parse-float
  129.                   (number->string (imag-part num))))))
  130.             (and realpart imagpart
  131.                  (append realpart imagpart))))))
  132.           (else #f))))))
  133.  
  134. ;; STR is a digit string representing a floating point mantissa, STR must
  135. ;; begin with "0", after which a decimal point is understood.
  136. ;; The output is a digit string rounded to NDIGS digits after the decimal
  137. ;; point implied between chars 0 and 1.
  138. ;; If STRIP-0S is not #F then trailing zeros will be stripped from the result.
  139. ;; In this case, STRIP-0S should be the minimum number of digits required
  140. ;; after the implied decimal point.
  141. (define (stdio:round-string str ndigs strip-0s)
  142.   (let* ((n (- (string-length str) 1))
  143.      (res
  144.       (cond ((< ndigs 0) "")
  145.         ((= n ndigs) str)
  146.         ((< n ndigs)
  147.          (let ((zeropad (make-string
  148.                  (max 0 (- (or strip-0s ndigs) n))
  149.                  (if (char-numeric? (string-ref str n))
  150.                      #\0 #\#))))
  151.            (if (zero? (string-length zeropad))
  152.                str
  153.                (string-append str zeropad))))
  154.         (else
  155.          (let ((res (substring str 0 (+ ndigs 1)))
  156.                (dig (lambda (i)
  157.                   (let ((c (string-ref str i)))
  158.                 (if (char-numeric? c)
  159.                     (string->number (string c))
  160.                     0)))))
  161.            (let ((ldig (dig (+ 1 ndigs))))
  162.              (if (or (> ldig 5)
  163.                  (and (= ldig 5)
  164.                   (let loop ((i (+ 2 ndigs)))
  165.                     (if (> i n) (odd? (dig ndigs))
  166.                     (if (zero? (dig i))
  167.                         (loop (+ i 1))
  168.                         #t)))))
  169.              (let inc! ((i ndigs))
  170.                (let ((d (dig i)))
  171.                  (if (< d 9)
  172.                  (string-set! res i
  173.                           (string-ref
  174.                            (number->string (+ d 1)) 0))
  175.                  (begin
  176.                    (string-set! res i #\0)
  177.                    (inc! (- i 1))))))))
  178.            res)))))
  179.     (if strip-0s
  180.     (let loop ((i (- (string-length res) 1)))
  181.       (if (or (<= i strip-0s)
  182.           (not (char=? #\0 (string-ref res i))))
  183.           (substring res 0 (+ i 1))
  184.           (loop (- i 1))))
  185.     res)))
  186.  
  187. (define (stdio:iprintf out format-string . args)
  188.   (cond
  189.    ((not (equal? "" format-string))
  190.     (let ((pos -1)
  191.       (fl (string-length format-string))
  192.       (fc (string-ref format-string 0)))
  193.  
  194.       (define (advance)
  195.     (set! pos (+ 1 pos))
  196.     (cond ((>= pos fl) (set! fc #f))
  197.           (else (set! fc (string-ref format-string pos)))))
  198.       (define (must-advance)
  199.     (set! pos (+ 1 pos))
  200.     (cond ((>= pos fl) (incomplete))
  201.           (else (set! fc (string-ref format-string pos)))))
  202.       (define (end-of-format?)
  203.     (>= pos fl))
  204.       (define (incomplete)
  205.     (slib:error 'printf "conversion specification incomplete"
  206.             format-string))
  207.       (define (wna)
  208.     (slib:error 'printf "wrong number of arguments"
  209.             (length args)
  210.             format-string))
  211.  
  212.       (let loop ((args args))
  213.     (advance)
  214.     (cond
  215.      ((end-of-format?)
  216.       ;;(or (null? args) (wna))    ;Extra arguments are *not* a bug.
  217.       )
  218.      ((eqv? #\\ fc);;Emulating C strings may not be a good idea.
  219.       (must-advance)
  220.       (and (case fc
  221.          ((#\n #\N) (out #\newline))
  222.          ((#\t #\T) (out slib:tab))
  223.          ;;((#\r #\R) (out #\return))
  224.          ((#\f #\F) (out slib:form-feed))
  225.          ((#\newline) #t)
  226.          (else (out fc)))
  227.            (loop args)))
  228.      ((eqv? #\% fc)
  229.       (must-advance)
  230.       (let ((left-adjust #f)    ;-
  231.         (signed #f)        ;+
  232.         (blank #f)
  233.         (alternate-form #f)    ;#
  234.         (leading-0s #f)        ;0
  235.         (width 0)
  236.         (precision -1)
  237.         (type-modifier #f)
  238.         (read-format-number
  239.          (lambda ()
  240.            (cond
  241.             ((eqv? #\* fc)    ; GNU extension
  242.              (must-advance)
  243.              (let ((ans (car args)))
  244.                (set! args (cdr args))
  245.                ans))
  246.             (else
  247.              (do ((c fc fc)
  248.               (accum 0 (+ (* accum 10)
  249.                       (string->number (string c)))))
  250.              ((not (char-numeric? fc)) accum)
  251.                (must-advance)))))))
  252.         (define (pad pre . strs)
  253.           (let loop ((len (string-length pre))
  254.              (ss strs))
  255.         (cond ((>= len width) (apply string-append pre strs))
  256.               ((null? ss)
  257.                (cond (left-adjust
  258.                   (apply string-append
  259.                      pre
  260.                      (append strs
  261.                          (list (make-string
  262.                             (- width len) #\space)))))
  263.                  (leading-0s
  264.                   (apply string-append
  265.                      pre
  266.                      (make-string (- width len) #\0)
  267.                      strs))
  268.                  (else
  269.                   (apply string-append
  270.                      (make-string (- width len) #\space)
  271.                      pre strs))))
  272.               (else
  273.                (loop (+ len (string-length (car ss))) (cdr ss))))))
  274.         (define integer-convert
  275.           (lambda (s radix)
  276.         (cond ((not (negative? precision))
  277.                (set! leading-0s #f)
  278.                (if (and (zero? precision)
  279.                 (eqv? 0 s))
  280.                (set! s ""))))
  281.         (set! s (cond ((symbol? s) (symbol->string s))
  282.                   ((number? s) (number->string s radix))
  283.                   ((or (not s) (null? s)) "0")
  284.                   ((string? s) s)
  285.                   (else "1")))
  286.         (let ((pre (cond ((equal? "" s) "")
  287.                  ((eqv? #\- (string-ref s 0))
  288.                   (set! s (substring s 1 (string-length s)))
  289.                   "-")
  290.                  (signed "+")
  291.                  (blank " ")
  292.                  (alternate-form
  293.                   (case radix
  294.                     ((8) "0")
  295.                     ((16) "0x")
  296.                     (else "")))
  297.                  (else ""))))
  298.           (pad pre
  299.                (if (< (string-length s) precision)
  300.                (make-string
  301.                 (- precision (string-length s)) #\0)
  302.                "")
  303.                s))))
  304.         (define (float-convert num fc)
  305.           (define (f digs exp strip-0s)
  306.         (let ((digs (stdio:round-string
  307.                  digs (+ exp precision) (and strip-0s exp))))
  308.           (cond ((>= exp 0)
  309.              (let* ((i0 (cond ((zero? exp) 0)
  310.                       ((char=? #\0 (string-ref digs 0)) 1)
  311.                       (else 0)))
  312.                 (i1 (max 1 (+ 1 exp)))
  313.                 (idigs (substring digs i0 i1))
  314.                 (fdigs (substring digs i1
  315.                           (string-length digs))))
  316.                (cons idigs
  317.                  (if (and (string=? fdigs "")
  318.                       (not alternate-form))
  319.                      '()
  320.                      (list "." fdigs)))))
  321.             ((zero? precision)
  322.              (list (if alternate-form "0." "0")))
  323.             ((and strip-0s (string=? digs "") (list "0")))
  324.             (else
  325.              (list "0."
  326.                    (make-string (min precision (- -1 exp)) #\0)
  327.                    digs)))))
  328.           (define (e digs exp strip-0s)
  329.         (let* ((digs (stdio:round-string
  330.                   digs (+ 1 precision) (and strip-0s 0)))
  331.                (istrt (if (char=? #\0 (string-ref digs 0)) 1 0))
  332.                (fdigs (substring
  333.                    digs (+ 1 istrt) (string-length digs)))
  334.                (exp (if (zero? istrt) exp (- exp 1))))
  335.           (list
  336.            (substring digs istrt (+ 1 istrt))
  337.            (if (and (string=? fdigs "") (not alternate-form))
  338.                "" ".")
  339.            fdigs
  340.            (if (char-upper-case? fc) "E" "e")
  341.            (if (negative? exp) "-" "+")
  342.            (if (< -10 exp 10) "0" "")
  343.            (number->string (abs exp)))))
  344.           (define (g digs exp)
  345.         (let ((strip-0s (not alternate-form)))
  346.           (set! alternate-form #f)
  347.           (cond ((<= (- 1 precision) exp precision)
  348.              (set! precision (- precision exp))
  349.              (f digs exp strip-0s))
  350.             (else
  351.              (set! precision (- precision 1))
  352.              (e digs exp strip-0s)))))
  353.           (define (k digs exp sep)
  354.         (let* ((units '#("y" "z" "a" "f" "p" "n" "u" "m" ""
  355.                  "k" "M" "G" "T" "P" "E" "Z" "Y"))
  356.                (base 8)        ;index of ""
  357.                (uind (let ((i (if (negative? exp)
  358.                       (quotient (- exp 3) 3)
  359.                       (quotient (- exp 1) 3))))
  360.                    (and
  361.                 (< -1 (+ i base) (vector-length units))
  362.                 i))))
  363.           (cond (uind
  364.              (set! exp (- exp (* 3 uind)))
  365.              (set! precision (max 0 (- precision exp)))
  366.              (append
  367.               (f digs exp #f)
  368.               (list sep
  369.                 (vector-ref units (+ uind base)))))
  370.             (else
  371.              (g digs exp)))))
  372.  
  373.           (cond ((negative? precision)
  374.              (set! precision 6))
  375.             ((and (zero? precision)
  376.               (char-ci=? fc #\g))
  377.              (set! precision 1)))
  378.           (let* ((str
  379.               (cond ((number? num)
  380.                  (number->string (exact->inexact num)))
  381.                 ((string? num) num)
  382.                 ((symbol? num) (symbol->string num))
  383.                 (else "???")))
  384.              (parsed (stdio:parse-float str)))
  385.         (letrec ((format-real
  386.               (lambda (signed? sgn digs exp . rest)
  387.                 (if (null? rest)
  388.                 (cons
  389.                  (if (char=? #\- sgn) "-"
  390.                      (if signed? "+" (if blank " " "")))
  391.                  (case fc
  392.                    ((#\e #\E) (e digs exp #f))
  393.                    ((#\f #\F) (f digs exp #f))
  394.                    ((#\g #\G) (g digs exp))
  395.                    ((#\k) (k digs exp ""))
  396.                    ((#\K) (k digs exp " "))))
  397.                 (append (format-real signed? sgn digs exp)
  398.                     (apply format-real #t rest)
  399.                     '("i"))))))
  400.           (if parsed
  401.               (apply pad (apply format-real signed parsed))
  402.               (pad "???")))))
  403.         (do ()
  404.         ((case fc
  405.            ((#\-) (set! left-adjust #t) #f)
  406.            ((#\+) (set! signed #t) #f)
  407.            ((#\ ) (set! blank #t) #f)
  408.            ((#\#) (set! alternate-form #t) #f)
  409.            ((#\0) (set! leading-0s #t) #f)
  410.            (else #t)))
  411.           (must-advance))
  412.         (cond (left-adjust (set! leading-0s #f)))
  413.         (cond (signed (set! blank #f)))
  414.  
  415.         (set! width (read-format-number))
  416.         (cond ((negative? width)
  417.            (set! left-adjust #t)
  418.            (set! width (- width))))
  419.         (cond ((eqv? #\. fc)
  420.            (must-advance)
  421.            (set! precision (read-format-number))))
  422.         (case fc            ;Ignore these specifiers
  423.           ((#\l #\L #\h)
  424.            (set! type-modifier fc)
  425.            (must-advance)))
  426.  
  427.         ;;At this point fc completely determines the format to use.
  428.         (if (null? args)
  429.         (if (memv (char-downcase fc)
  430.               '(#\c #\s #\a #\d #\i #\u #\o #\x #\b
  431.                 #\f #\e #\g #\k))
  432.             (wna)))
  433.  
  434.         (case fc
  435.           ;; only - is allowed between % and c
  436.           ((#\c #\C)        ; C is enhancement
  437.            (and (out (string (car args))) (loop (cdr args))))
  438.  
  439.           ;; only - flag, no type-modifiers
  440.           ((#\s #\S)        ; S is enhancement
  441.            (let ((s (cond
  442.              ((symbol? (car args)) (symbol->string (car args)))
  443.              ((not (car args)) "(NULL)")
  444.              (else (car args)))))
  445.          (cond ((not (or (negative? precision)
  446.                  (>= precision (string-length s))))
  447.             (set! s (substring s 0 precision))))
  448.          (and (out (cond
  449.                 ((<= width (string-length s)) s)
  450.                 (left-adjust
  451.                  (string-append
  452.                   s (make-string (- width (string-length s)) #\ )))
  453.                 (else
  454.                  (string-append
  455.                   (make-string (- width (string-length s))
  456.                        (if leading-0s #\0 #\ )) s))))
  457.               (loop (cdr args)))))
  458.  
  459.           ;; SLIB extension
  460.           ((#\a #\A)        ;#\a #\A are pretty-print
  461.            (require 'generic-write)
  462.            (let ((os "") (pr precision))
  463.          (generic-write
  464.           (car args) (not alternate-form) #f
  465.           (cond ((and left-adjust (negative? pr))
  466.              (set! pr 0)
  467.              (lambda (s)
  468.                (set! pr (+ pr (string-length s)))
  469.                (out s)))
  470.             (left-adjust
  471.              (lambda (s)
  472.                (define sl (- pr (string-length s)))
  473.                (set! pr (cond ((negative? sl)
  474.                        (out (substring s 0 pr)) 0)
  475.                       (else (out s) sl)))
  476.                (positive? sl)))
  477.             ((negative? pr)
  478.              (set! pr width)
  479.              (lambda (s)
  480.                (set! pr (- pr (string-length s)))
  481.                (cond ((not os) (out s))
  482.                  ((negative? pr)
  483.                   (out os)
  484.                   (set! os #f)
  485.                   (out s))
  486.                  (else (set! os (string-append os s))))
  487.                #t))
  488.             (else
  489.              (lambda (s)
  490.                (define sl (- pr (string-length s)))
  491.                (cond ((negative? sl)
  492.                   (set! os (string-append
  493.                         os (substring s 0 pr))))
  494.                  (else (set! os (string-append os s))))
  495.                (set! pr sl)
  496.                (positive? sl)))))
  497.          (cond ((and left-adjust (negative? precision))
  498.             (cond
  499.              ((> width pr) (out (make-string (- width pr) #\ )))))
  500.                (left-adjust
  501.             (cond
  502.              ((> width (- precision pr))
  503.               (out (make-string (- width (- precision pr)) #\ )))))
  504.                ((not os))
  505.                ((<= width (string-length os)) (out os))
  506.                (else (and (out (make-string
  507.                     (- width (string-length os)) #\ ))
  508.                   (out os)))))
  509.            (loop (cdr args)))
  510.           ((#\d #\D #\i #\I #\u #\U)
  511.            (and (out (integer-convert (car args) 10)) (loop (cdr args))))
  512.           ((#\o #\O)
  513.            (and (out (integer-convert (car args) 8)) (loop (cdr args))))
  514.           ((#\x #\X)
  515.            (and (out ((if (char-upper-case? fc)
  516.                   string-upcase string-downcase)
  517.               (integer-convert (car args) 16)))
  518.             (loop (cdr args))))
  519.           ((#\b #\B)
  520.            (and (out (integer-convert (car args) 2)) (loop (cdr args))))
  521.           ((#\%) (and (out #\%) (loop args)))
  522.           ((#\f #\F #\e #\E #\g #\G #\k #\K)
  523.            (and (out (float-convert (car args) fc)) (loop (cdr args))))
  524.           (else
  525.            (cond ((end-of-format?) (incomplete))
  526.              (else (and (out #\%) (out fc) (out #\?) (loop args))))))))
  527.      (else (and (out fc) (loop args)))))))))
  528.  
  529. (define (stdio:fprintf port format . args)
  530.   (let ((cnt 0))
  531.     (apply stdio:iprintf
  532.        (lambda (x)
  533.          (cond ((string? x)
  534.             (set! cnt (+ (string-length x) cnt)) (display x port) #t)
  535.            (else (set! cnt (+ 1 cnt)) (display x port) #t)))
  536.        format args)
  537.     cnt))
  538.  
  539. (define (stdio:printf format . args)
  540.   (apply stdio:fprintf (current-output-port) format args))
  541.  
  542. (define (stdio:sprintf str format . args)
  543.   (let* ((cnt 0)
  544.      (s (cond ((string? str) str)
  545.           ((number? str) (make-string str))
  546.           ((not str) (make-string 100))
  547.           (else (slib:error 'sprintf "first argument not understood"
  548.                     str))))
  549.      (end (string-length s)))
  550.     (apply stdio:iprintf
  551.        (lambda (x)
  552.          (cond ((string? x)
  553.             (if (or str (>= (- end cnt) (string-length x)))
  554.             (do ((lend (min (string-length x) (- end cnt)))
  555.                  (i 0 (+ i 1)))
  556.                 ((>= i lend))
  557.               (string-set! s cnt (string-ref x i))
  558.               (set! cnt (+ cnt 1)))
  559.             (let ()
  560.               (set! s (string-append (substring s 0 cnt) x))
  561.               (set! cnt (string-length s))
  562.               (set! end cnt))))
  563.            ((and str (>= cnt end)))
  564.            (else (cond ((and (not str) (>= cnt end))
  565.                 (set! s (string-append s (make-string 100)))
  566.                 (set! end (string-length s))))
  567.              (string-set! s cnt (if (char? x) x #\?))
  568.              (set! cnt (+ cnt 1))))
  569.          (not (and str (>= cnt end))))
  570.        format
  571.        args)
  572.     (cond ((string? str) cnt)
  573.       ((eqv? end cnt) s)
  574.       (else (substring s 0 cnt)))))
  575.  
  576. (define printf stdio:printf)
  577. (define fprintf stdio:fprintf)
  578. (define sprintf stdio:sprintf)
  579.  
  580. ;;(do ((i 0 (+ 1 i))) ((> i 50)) (printf "%s\n" (sprintf i "%#-13a:%#13a:%-13.8a:" "123456789" "123456789" "123456789")))
  581.